perm filename UMATCH.QLA[QLA,LSP] blob
sn#732973 filedate 1983-11-17 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 the matching function
C00005 00003 Macros for Unification
C00035 00004 Choice Macros
C00040 00005 The Unification Matcher
C00060 ENDMK
C⊗;
;;;;;;;;;; the matching function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (MATCH p d <variables to retain>) attempts to match p against d
;;; (catch-match <form>) will intercept any backtracks, used in RESTRICT
;;; clauses.
;;*PAGE
;;; Macros for Unification
(DECLARE (SETSYNTAX 35. 2 35.))
(DECLARE (SPECIAL MATCH:CE MATCH:ALIST COMPILE-MACROS UMATCH-ALIST))
(declare (special MATCH:full-predicate MATCH:OCCURS))
(setq MATCH:full-predicate ())
(declare (fasload struct fas dsk (mac lsp)))
(SETQ COMPILE-MACROS NIL MATCH:OCCURS () UMATCH-ALIST ())
(DEFMACRO SPAWN (FORM)
`(FUNCALL (QLAMBDA T () ,FORM)))
(DEFMACRO MAP-AND (FUN LIST)
`(QCATCH 'MAP-AND
(DO ((L ,LIST (CDR L)))
((NULL L) T)
(SPAWN
(COND ((NOT (FUNCALL ,FUN (CAR L)))
(THROW 'MAP-AND ())))))))
(M-DEFUN M-OCCURS (X L)
(COND ((MEMQ L (CDR (ASSQ X MATCH:OCCURS))) T)
((EQ X L) ())
(T (CATCH 'OCCURS (M-OCCURS1 X L L)))))
(M-DEFUN M-OCCURS1 (X L TOP)
(COND ((NULL L) ())
((EQ X L)
(LET ((ENTRY (ASSQ X MATCH:OCCURS)))
(COND (ENTRY
(NCONC ENTRY `(,TOP)))
(T (PUSH `(,X . (,TOP))
MATCH:OCCURS))))
(THROW 'OCCURS T))
((ATOM L) ())
(T (SPAWN (M-OCCURS1 X (CAR L) TOP))
(M-OCCURS1 X (CDR L) TOP))))
(MACRODEF MAKE-SPECIAL-FORM (X) (CONS '-SPECIAL-FORM- X))
(MACRODEF SPECIAL-FORM (X)
(LET QQQ ← X DO
(COND ((M-SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(MACRODEF M-CHAR1 (ATOM)
;; returns the 1st character of an atom.
(COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))
(MACRODEF REAL-ATOM (MATCH:X)(AND MATCH:X (ATOM MATCH:X)))
(DECLARE (SPECIAL -SEEN-))
(M-DEFUN M-CHECK (L)
((LAMBDA(-SEEN-)
(M-CHECK1 L)) ()))
(M-DEFUN M-CHECK1 (L)
(COND ((MEMQ L -SEEN-) L)
((ATOM L) L)
((HUNKP L) (PUSH L -SEEN-) L)
((EQ (CAR L) '-SPECIAL-FORM-)
(CDR L))
((MEMQ (CAR L) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR $CH $CHOOSE))
(CADR L))
(T
(PUSH l -SEEN-)
((QLAMBDA T (X Y)
(CONS X Y))
(M-CHECK1 (CAR L) )
(M-CHECK1 (CDR L))))))
(MACRODEF PROCESSED-SPECIAL-FORMP (X)
(LET ((Q X))
(COND ((ATOM Q) ())
(T (EQ (CAR Q) '-SPECIAL-FORM-)))))
(MACRODEF ALL-TRUE (FUN MATCH:L)
(QCATCH 'ALL-TRUE
(DO ((L MATCH:L (CDR L)))
((NULL L) T)
(SPAWN
(COND ((OR (RESTRICTP *Q*)
(M-SPECIAL-FORMP *Q*)
(FUNCALL FUN *Q*))
T)
(T (THROW 'ALL-TRUE ())))))))
(MACRODEF RESTRICTP (MATCH:X) (AND (NOT (ATOM MATCH:X))
(MEMQ (CAR MATCH:X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))
(MACRODEF EXCHANGE (X Y)
((LAMBDA (Q)
(SETQ X Y)
(SETQ Y Q))
X))
(M-DEFUN M-SPECIAL-FORMP (X)
(COND (MATCH:FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(AND (NOT (EQ X '=))
(MEMQ (M-CHAR1 X) '(? * =)))))
(T (OR (EQ (CAR X) '-SPECIAL-FORM-)
(RESTRICTP X)))) )
(MACRODEF CLAUSE-?-RESTRICTIONS (P D CP CD ALIST)
(COND
((EQ (CADAR P) '?)
;;; normal case of ($r ? ...)
(COND ((M-SPECIAL-FORMP (CAR D))
(SETQ P (CONS (CONS '-SPECIAL-FORM- (CAR P)) (CDR P)))
(EXCHANGE P D)(EXCHANGE CP CD))
(T
(SETQ P (CDR P) D (CDR D))))
(M-UMATCH P D CP CD ALIST NOBIND))
((EQ (M-CHAR1 (CADAR P)) '?)
;;; case of ($r ?foo ...)
((LAMBDA (*T*)
(COND (*T* (SETQ P (CONS (SPECIAL-FORM (CDR *T*)) (CDR P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(LET ((SPECP ())(RESTRP ()))
(COND (
(QCATCH 'MATCH:DECISION-POINT
(COND
((M-OCCURS (CADAR P)
(COND ((RESTRICTP (CAR D))
(CADAR D))
(T (CAR D))))
())
((M-SPECIAL-FORMP (CAR D))
(LET ((G (GENSYM))
(ALIST ALIST))
(COND ((RESTRICTP (CAR D))
(COND ((EQ (M-CHAR1 (CADAR D))
'?)
(SETQ SPECP T RESTRP T)
(PUSH (CONS (CADAR D) G) ALIST))))
((EQ (M-CHAR1 (CAR D)) '?)
(SETQ SPECP T)
(PUSH (CONS (CAR D) G) ALIST)))
(COND ((PROCESSED-SPECIAL-FORMP (CAR D))
(M-UMATCH (CDR D) (CDR P) CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND))
(T (M-UMATCH D P CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND)))))
(T (M-UMATCH (CDR P)(CDR D) CP CD
(CONS (CONS (CADAR P)
(CAR D))
ALIST) NOBIND)))
)
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(M-CHECK (CAR D)))
UMATCH-ALIST)
(COND (SPECP
(COND (RESTRP
(PUSH `(,(CADAR D) . ,(M-CHECK (CADAR P)))
UMATCH-ALIST))
(T (PUSH `(,(CAR D) . ,(M-CHECK (CADAR P)))
UMATCH-ALIST))))))
(() (SET (CADAR P) (M-CHECK (CAR D)))
(COND (SPECP
(COND (RESTRP
(SET (CADAR D) (M-CHECK (CADAR P))))
(T (SET (CAR D) (M-CHECK (CADAR P))))))))
(T ()))
(*THROW 'MATCH:DECISION-POINT T ))
(T (*THROW 'MATCH:DECISION-POINT ())))))))
(ASSQ (CADAR P) ALIST)))))
(DEFMACRO EXAMINE-POSSIBILITY-1 ()
`(COND ((MAP-AND
(LAMBDA (Q)
(COND
((FUNCALL Q L)
T)))
(CDDAR P))
(COND
((AND L
(M-SPECIAL-FORMP (CAR OD)))
(SPAWN (M-UMATCH
OD OP CD CP ALIST NOBIND))
(T
(SPAWN (M-UMATCH (CDR P) D CP CD
ALIST NOBIND)))))
(COND ((NOT SP)
(SPAWN (M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))))))
(MACRODEF CLAUSE-*-RESTRICTIONS (P D CP CD ALIST)
(COND ((EQ (CADAR P) '*)
(DO ((L () (NCONC L (NCONS (CAR D))))
(SP (M-SPECIAL-FORMP (CAR D)))
(OD D OD)
(OP P OP)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) NIL)
(SPAWN (EXAMINE-POSSIBILITY-1))
))
;;;HERE
((EQ (M-CHAR1 (CADAR P)) '*)
((LAMBDA (*T*)
(COND (*T* (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (CDR *T*))
T))))
(CDDAR P)))
(SETQ P (APPEND
(SPECIAL-FORM (CDR *T*)) (CDR P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (*THROW 'MATCH:DECISION-POINT NIL ))))
(T
(DO ((L () (NCONC L (NCONS (CAR D))))
(SP (M-SPECIAL-FORMP (CAR D)))
(OP P OP)
(OD D OD)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW 'MATCH:DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND((FUNCALL Q L)
T))))
(CDDAR P)))
(COND
((AND (*CATCH 'MATCH:DECISION-POINT
(COND
((AND L
(M-SPECIAL-FORMP (CAR OD)))
(M-UMATCH OD OP CD CP
(CONS
(CONS (CADAR P)
(CONS
(CONS
'-SPECIAL-FORM-
(CAR OD))
(CDR L)))
ALIST) NOBIND))
(T (M-UMATCH
(CDR P) D CP CD
(CONS
(CONS (CADAR P)
L)
ALIST) NOBIND)) )
)
(OR (NOT SP)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND))))
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(M-CHECK L))
UMATCH-ALIST))
(() (SET (CADAR P) (M-CHECK L)))
(T ()))
(*THROW 'MATCH:DECISION-POINT T )))))))
)))
(ASSQ (CADAR P) ALIST))))
(MACRODEF CLAUSE-*-IRESTRICTIONS (P D CP CD ALIST)
(COND ((EQ (CADAR P) '*)
;;; try all possibilities
(DO ((L () (NCONC L (NCONS (CAR D))))
(F (CAR D)(CAR D))
(SP (M-SPECIAL-FORMP (CAR D)))
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW 'MATCH:DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (NULL L)
(RESTRICTP F)
(M-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(CDDAR P)))
(COND
((AND (*CATCH 'MATCH:DECISION-POINT
(COND ((AND L
(M-SPECIAL-FORMP (CAR D)))
(M-UMATCH D (CDR P) CD CP ALIST NOBIND))
(T (M-UMATCH (CDR P) D CP CD
ALIST NOBIND)))
)
(OR (NOT SP)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND))))
(*THROW 'MATCH:DECISION-POINT T )))))))
)
((EQ (M-CHAR1 (CADAR P)) '*)
((LAMBDA (*T*)
(COND
(*T*
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (RESTRICTP *T*)
(ALL-TRUE Q *T*))
T))))
(CDDAR P)))
(COND ((*CATCH 'MATCH:DECISION-POINT
(M-UMATCH
(CAR P)(CAR D) () () ALIST NOBIND)
)
(SETQ P (APPEND (SPECIAL-FORM (CDR *T*)) (CDR P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (*THROW 'MATCH:DECISION-POINT ()
))))
(T (*THROW 'MATCH:DECISION-POINT NIL ))))
(T
(DO ((L () (NCONC L (NCONS (CAR D))))
(F (CAR D)(CAR D))
(OD D OD)
(SP (M-SPECIAL-FORMP (CAR D)))
(OP P OP)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW 'MATCH:DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (NULL L)
(RESTRICTP F)
(M-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(CDDAR P)))
(COND
((AND (*CATCH 'MATCH:DECISION-POINT
(COND ((AND L
(M-SPECIAL-FORMP (CAR OD)))
(M-UMATCH OD OP CD CP
(CONS
(CONS (CADAR P)
(CONS (CONS
'-SPECIAL-FORM-
(CAR OD)) (CDR L)))
ALIST) NOBIND))
(T
(M-UMATCH (CDR P) D CP CD
(CONS
(CONS (CADAR P) L)
ALIST) NOBIND)))
)
(OR (NOT SP)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND))))
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(M-CHECK L))
UMATCH-ALIST))
(() (SET (CADAR P) (M-CHECK L)))
(T ()))
(*THROW 'MATCH:DECISION-POINT T )))))))
)))
(ASSQ (CADAR P) ALIST)) )
(MACRODEF CLAUSE-?-VARIABLE (P D CP CD ALIST)
((LAMBDA (*T*)
(COND (*T* (SETQ P (CONS (SPECIAL-FORM (CDR *T*)) (CDR P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(LET ((SPECP ())
(RESTRP ()))
(COND
((*CATCH 'MATCH:DECISION-POINT
(COND ((M-OCCURS (CAR P) (COND ((RESTRICTP (CAR D))
(CADAR D))
(T (CAR D))))
())
((M-SPECIAL-FORMP (CAR D))
(LET ((G (GENSYM))
(ALIST ALIST))
(COND ((RESTRICTP (CAR D))
(COND ((EQ (M-CHAR1 (CADAR D))
'?)
(SETQ SPECP T RESTRP T)
(PUSH (CONS (CADAR D) G) ALIST))))
((EQ (M-CHAR1 (CAR D)) '?)
(SETQ SPECP T)
(PUSH (CONS (CAR D) G) ALIST)))
(COND ((PROCESSED-SPECIAL-FORMP (CAR D))
(M-UMATCH (CDR D) (CDR P) CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND))
(T (M-UMATCH D P CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND)))))
(T
(M-UMATCH (CDR P)(CDR D) CP CD
(CONS (CONS (CAR P)(CAR D))ALIST) NOBIND)))
)
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR P) . ,(M-CHECK (CAR D)))
UMATCH-ALIST)
(COND (SPECP
(COND (RESTRP
(PUSH `(,(CADAR D) . ,(M-CHECK (CAR P)))
UMATCH-ALIST))
(T (PUSH `(,(CAR D) . ,(M-CHECK (CAR P)))
UMATCH-ALIST))))))
(() (SET (CAR P) (M-CHECK (CAR D)))
(COND (SPECP
(COND (RESTRP
(SET (CADAR D) (M-CHECK (CAR P))))
(T (SET (CAR D) (M-CHECK (CAR P))))))))
(T ()))
(*THROW 'MATCH:DECISION-POINT T ))
(T (*THROW 'MATCH:DECISION-POINT () )))))))
(ASSQ (CAR P) ALIST)))
(MACRODEF CLAUSE-* (P D CP CD ALIST)
;;; try all possibilities
(DO ((L () (NCONC L (NCONS (CAR D))))
(D D (CDR D))
(SP (M-SPECIAL-FORMP (CAR D)))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW 'MATCH:DECISION-POINT NIL ))
(COND
((AND (*CATCH 'MATCH:DECISION-POINT
(COND
((AND L
(M-SPECIAL-FORMP (CAR D)))
(M-UMATCH D (CDR P) CP CD ALIST NOBIND))
(T (M-UMATCH (CDR P) D CP CD ALIST NOBIND) ))
)
(OR (NOT SP)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND))))
(*THROW 'MATCH:DECISION-POINT T )))))
)
(MACRODEF CLAUSE-*-VARIABLE (P D CP CD ALIST)
((LAMBDA (*T*)
(COND (*T* (SETQ P (APPEND (SPECIAL-FORM (CDR *T*)) (CDR P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(DO ((L () (NCONC L (NCONS (CAR D))))
(D D (CDR D))
(SP (M-SPECIAL-FORMP (CAR D)))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW 'MATCH:DECISION-POINT NIL ))
(COND
((AND (*CATCH 'MATCH:DECISION-POINT
(M-UMATCH (CDR P) D CP CD
(CONS (CONS (CAR P) L)
ALIST) NOBIND)
)
(OR (NOT SP)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND))))
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR P) . ,(M-CHECK L))
UMATCH-ALIST))
(() (SET (CAR P) (M-CHECK L)))
(T ()))
(*THROW 'MATCH:DECISION-POINT T )))))
)))
(ASSQ (CAR P) ALIST)) )
(MACRODEF CLAUSE-=?-VARIABLE (P D CP CD ALIST)
((LAMBDA (*T*)
(COND ((EQ (CAR *T*) '?)
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ P (CONS (CDR VAL) (CDR P))))
(T
(SETQ P
(CONS (SYMEVAL VAR) (CDR P)))))
(M-UMATCH P D CP CD ALIST NOBIND))
(ASSQ VAR MATCH:ALIST)))
(IMPLODE *T*)))
(T
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ P (APPEND (CDR VAL) (CDR P))))
(T
(SETQ P
(APPEND (SYMEVAL VAR) (CDR P)))))
(M-UMATCH P D CP CD ALIST NOBIND))
(ASSQ VAR MATCH:ALIST)))
(IMPLODE *T*)))))
(CDR (EXPLODE (CAR P)))))
;;; Choice Macros
(DEFMACRO CATCH-MATCH (FORM)
`(*CATCH 'MATCH:DECISION-POINT ,FORM))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ())
(MAPEX T))
(EVAL-WHEN (COMPILE EVAL)
(DEFSTRUCT CHOOSER
PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY
SEARCH-LIST
CONSTANTP))
(DEFMACRO CHOOSEP (X) `(AND (NOT (ATOM ,X))
(MEMQ (CAR ,X) '($CHOOSE $CH))))
(DEFMACRO CHOOSE-VAR (X) `(CADR ,X))
(DEFMACRO EMPTY-CHOICE (X) `(EMPTY ,X))
(DEFMACRO COPY (X) `(MAPCAR (FUNCTION (LAMBDA (X) X)) ,X)))
(M-DEFUN M-UCHOOSE-FIRST (P D)
(M-UCHOOSER
(MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D
CONSTANTP (AND (ATOM P) (NOT (EQ (M-CHAR1 P) '?)))
SEARCH-LIST D
CHOICE ()
EMPTY ()
VARIABLE (COND ((ATOM P) P)
(T (CADR P)))
PREDICATES (COND ((ATOM P) ())
((RESTRICTP P) (CDDR P))))))
(M-DEFUN M-UCHOOSE-NEXT (OLD-CHOOSER)
(M-UCHOOSER
(MAKE-CHOOSER
PAST-CHOICES (PAST-CHOICES OLD-CHOOSER)
ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER)
CONSTANTP (CONSTANTP OLD-CHOOSER)
SEARCH-LIST (SEARCH-LIST OLD-CHOOSER)
CHOICE ()
EMPTY ()
VARIABLE (VARIABLE OLD-CHOOSER)
PREDICATES (PREDICATES OLD-CHOOSER))))
(DEFMACRO NEXT-CHOICE (X) `(CHOICE ,X))
(DECLARE (*LEXPR UMATCH))
(M-DEFUN MATCH-MEMQ (P L)
(DO ((L L (CDR L)))
((NULL L) ())
(COND ((UMATCH P (CAR L)) (RETURN L)))))
(M-DEFUN M-UCHOOSER (CHOOSER)
(LET ((P (VARIABLE CHOOSER))
(D (COPY (ORIGINAL-DATA CHOOSER)))
(SL (COPY (SEARCH-LIST CHOOSER))))
(LET ((CH ()))
(COND ((CONSTANTP CHOOSER)
(COND ((SETQ SL (MATCH-MEMQ P SL))
(SETQ CH `(,(CAR SL) . ,(DELQ (CAR SL) D)))
(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
(SETF (EMPTY CHOOSER) T))
(T (SETF (CHOICE CHOOSER) CH)
(SETF (SEARCH-LIST CHOOSER) (CDR SL))
(SETF (PAST-CHOICES CHOOSER)
`(,CH . ,(PAST-CHOICES CHOOSER))))))
(T (SETF (EMPTY CHOOSER) T))))
(T (LET ((CAND (M-USEARCH (PREDICATES CHOOSER) SL)))
(COND (CAND
(SETQ CH `(,(CAR CAND)
. ,(DELQ (CAR CAND)
D)))
(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
(SETF (EMPTY CHOOSER) T))
(T (SETF (CHOICE CHOOSER) CH)
(SETF (SEARCH-LIST CHOOSER) (CDR CAND))
(SETF (PAST-CHOICES CHOOSER)
`(,CH . ,(PAST-CHOICES CHOOSER))))))
(T (SETF (EMPTY CHOOSER) T))))))))
CHOOSER)
(M-DEFUN M-USEARCH (PREDS L)
(DO ((L L (CDR L)))
((NULL L) ())
(COND ((APPLY 'AND
(MAPCAR (FUNCTION (LAMBDA (F)
(FUNCALL F (CAR L))))
PREDS))
(RETURN L)))))
(MACRODEF CHOOSE-CLAUSE (P D CP CD ALIST)
(LET ((PAT (CHOOSE-VAR (CAR P))))
(DO ((DAT (M-UCHOOSE-FIRST PAT D)
(M-UCHOOSE-NEXT DAT)))
((EMPTY-CHOICE DAT) (*THROW 'MATCH:DECISION-POINT ()))
(COND ((*CATCH 'MATCH:DECISION-POINT
(M-UMATCH
(CONS PAT (CDR P))
(NEXT-CHOICE DAT) CP CD ALIST NOBIND))
(*THROW 'MATCH:DECISION-POINT T))))))
;;; The Unification Matcher
;;; Matches 2 patterns.
(declare (special *statistics *calls)(fixnum *calls))
(setq *statistics () *calls 0)
(M-DEFUN *calls () *calls)
(M-DEFUN *statistics (x)(and x (setq *calls 0))(setq *statistics x))
;;; (UMATCH <pat> <data> <initial alist, optional>)
(M-DEFUN UMATCH MATCH:n
(AND *STATISTICS (SETQ *CALLS (1+ *CALLS)))
((LAMBDA(MATCH:OCCURS)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 MATCH:n)(MAPCAR (FUNCTION (LAMBDA(MATCH:Q)(CONS MATCH:Q (SYMEVAL MATCH:Q))))
(ARG 3)))) ()) )) NIL))
;;; (UMATCH-NOBIND <pat> <data> <initial alist, optional>)
(M-DEFUN UMATCH-NOBIND MATCH:n
((LAMBDA (MATCH:OCCURS)
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 MATCH:n)(MAPCAR (FUNCTION (LAMBDA(MATCH:Q)(CONS MATCH:Q (SYMEVAL MATCH:Q))))
(ARG 3)))) T) )) NIL))
;;; (UMATCH-PAIR <pat> <data> <initial alist, optional>)
(M-DEFUN UMATCH-PAIR MATCH:n
((LAMBDA(MATCH:OCCURS)
(SETQ UMATCH-ALIST ())
(*CATCH 'MATCH:DECISION-POINT
(M-UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 MATCH:n)(MAPCAR (FUNCTION (LAMBDA(MATCH:Q)(CONS MATCH:Q (SYMEVAL MATCH:Q))))
(ARG 3)))) 'PAIR) )) NIL))
;;; MATCH:P is the pattern
;;; MATCH:D is the data
;;; MATCH:CP is the pattern to UMATCH against MATCH:CD if MATCH:P and MATCH:D UMATCH (i.e. a continuation)
;;; MATCH:CD is the data for the continuation
;;; ALIST is the current alist
(M-DEFUN M-UMATCH (MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST NOBIND)
(PROG NIL
UMATCH
(OR
(COND
;;; no more pattern
((AND (NULL MATCH:P) (NULL MATCH:CP))
;;; so there had better be no more data, unless there are some * vars etc
(COND ((AND (NULL MATCH:D)(NULL MATCH:CD))
(*THROW 'MATCH:DECISION-POINT T ))
;;; more data loses in some cases
(T (COND ((OR (ATOM MATCH:D)
(MEMQ (CAR MATCH:D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP MATCH:D))
;;; if MATCH:D=?<var> or = nil
(SETQ MATCH:D (NCONS MATCH:D) MATCH:P '(NIL))
(M-UMATCH P D CP CD ALIST NOBIND))
((EQ (CAR MATCH:D) '*)
;;; MATCH:D=(* ...) could work if (CDR MATCH:D) is all *-variables
(SETQ MATCH:D (CDR MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(LET ((VAR ()))
(COND ((EQ (M-CHAR1 (CAR MATCH:D)) '*)
(SETQ VAR (CAR MATCH:D)))
((AND (PROCESSED-SPECIAL-FORMP (CAR MATCH:D))
(EQ (M-CHAR1 (CDR (CAR MATCH:D))) '*))
(SETQ VAR (CDR (CAR MATCH:D)))))
(COND (VAR
;;; we succeed if (CAR MATCH:D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
((LAMBDA(*T*)
(COND (*T*
(SETQ MATCH:D
(APPEND (SPECIAL-FORM (CDR *T*))
(CDR MATCH:D)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (COND ((*CATCH 'MATCH:DECISION-POINT
(M-UMATCH
NIL (CDR MATCH:D) MATCH:CP MATCH:CD
(CONS (CONS VAR NIL)
MATCH:ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,VAR . ())
UMATCH-ALIST))
(() (SET VAR ()))
(T ()))
(*THROW 'MATCH:DECISION-POINT T ))
(T (*THROW 'MATCH:DECISION-POINT () ))))))
(ASSQ VAR MATCH:ALIST)))
(T (*THROW 'MATCH:DECISION-POINT NIL )))))))))
((NULL MATCH:P)
;;; if MATCH:P is null, but MATCH:D isn't, something is wrong sometimes
(COND (MATCH:D
(COND ((OR (ATOM MATCH:D)
(MEMQ (CAR MATCH:D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP MATCH:D))
;;; if MATCH:D=?<var> or = nil
(SETQ MATCH:D (NCONS MATCH:D) MATCH:P '(NIL))
(M-UMATCH P D CP CD ALIST NOBIND))
((EQ (CAR MATCH:D) '*)
;;; MATCH:D=(* ...) could work if (CDR MATCH:D) is all *-variables
(SETQ MATCH:D (CDR MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(LET ((VAR ()))
(COND ((EQ (M-CHAR1 (CAR MATCH:D)) '*)
(SETQ VAR (CAR MATCH:D)))
((AND (PROCESSED-SPECIAL-FORMP (CAR MATCH:D))
(EQ (M-CHAR1 (CDR (CAR MATCH:D))) '*))
(SETQ VAR (CDR (CAR MATCH:D)))))
(COND (VAR
;;; we succeed if (CAR MATCH:D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
((LAMBDA(*T*)
(COND (*T*
(SETQ MATCH:D
(APPEND (SPECIAL-FORM (CDR *T*))
(CDR MATCH:D)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (COND ((*CATCH 'MATCH:DECISION-POINT
(M-UMATCH
NIL (CDR MATCH:D) MATCH:CP MATCH:CD
(CONS (CONS VAR NIL)
MATCH:ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,VAR . ())
UMATCH-ALIST))
(() (SET VAR ()))
(T ()))
(*THROW 'MATCH:DECISION-POINT T ))
(T (*THROW 'MATCH:DECISION-POINT () ))))))
(ASSQ VAR MATCH:ALIST)))
(T (SETQ MATCH:P (CAR MATCH:CP) MATCH:D (CAR MATCH:CD) MATCH:CP (CDR MATCH:CP) MATCH:CD (CDR MATCH:CD))
(M-UMATCH P D CP CD ALIST NOBIND)))))))))
((AND (NULL MATCH:D)
(NOT (RESTRICTP (CAR MATCH:P))))
;;; if MATCH:D is null and MATCH:P isn't, we can still win
(COND ((OR (ATOM MATCH:P)
(MEMQ (CAR MATCH:P) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP MATCH:D))
;;; if MATCH:P=?<var> or = nil
(SETQ MATCH:P (NCONS MATCH:P) MATCH:D '(NIL))
(M-UMATCH P D CP CD ALIST NOBIND))
((EQ (CAR MATCH:P) '*)
;;; MATCH:P=(* ...) could work if (CDR MATCH:P) is all *-variables
(SETQ MATCH:P (CDR MATCH:P))
(M-UMATCH P D CP CD ALIST NOBIND))
(T
(LET ((VAR ()))
(COND ((EQ (M-CHAR1 (CAR MATCH:P)) '*)
(SETQ VAR (CAR MATCH:P)))
((AND (PROCESSED-SPECIAL-FORMP (CAR MATCH:P))
(EQ (M-CHAR1 (CDR (CAR MATCH:P))) '*))
(SETQ VAR (CDR (CAR MATCH:P)))))
(COND (VAR
;;; we succeed if (CAR MATCH:P) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
((LAMBDA(*T*)
(COND (*T*
(SETQ MATCH:P
(APPEND (SPECIAL-FORM (CDR *T*))
(CDR MATCH:P)))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (COND ((*CATCH 'MATCH:DECISION-POINT
(M-UMATCH
(CDR MATCH:P)() MATCH:CP MATCH:CD
(CONS (CONS VAR NIL)
MATCH:ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,VAR . ())
UMATCH-ALIST))
(() (SET VAR ()))
(T ()))
(*THROW 'MATCH:DECISION-POINT T ))
(T (*THROW 'MATCH:DECISION-POINT () ))))))
(ASSQ VAR MATCH:ALIST)))
(T (*THROW 'MATCH:DECISION-POINT NIL )))))))
((OR (REAL-ATOM MATCH:P) (REAL-ATOM MATCH:D)
(RESTRICTP MATCH:P)(RESTRICTP MATCH:D))
;;; here we listify things if necessary
(SETQ MATCH:P (NCONS MATCH:P) MATCH:D (NCONS MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND))
;;; ? restrictions
((AND (NOT (ATOM (CAR MATCH:P)))
(MEMQ (CAAR MATCH:P) '($R RESTRICT ⊗R))
(EQ (M-CHAR1 (CADAR MATCH:P)) '?)
(NOT (NULL MATCH:D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (MATCH:PRED) (COND ((OR (RESTRICTP (CAR MATCH:D))
(M-SPECIAL-FORMP (CAR MATCH:D))
(FUNCALL MATCH:PRED (CAR MATCH:D)))
T))))
(CDDAR MATCH:P))))
(COND ((EQ (M-CHAR1 (CADAR MATCH:P)) '?)
(CLAUSE-?-RESTRICTIONS MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((AND (NOT (EQ (CADAR MATCH:P) '=))
(EQ (M-CHAR1 (CADAR MATCH:P)) '=))
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ MATCH:P (CONS (LIST (CAAR MATCH:P) VAR (CDDAR MATCH:P))
(CDR MATCH:P))))
(T (SETQ MATCH:P (CONS (LIST (CAAR MATCH:P) VAR (CDDAR MATCH:P))
(CDR MATCH:P))
MATCH:ALIST (CONS (CONS VAR (SYMEVAL VAR))
MATCH:ALIST)))))
(ASSQ VAR MATCH:ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR MATCH:P)))))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (*THROW 'MATCH:DECISION-POINT () ))))
((AND (NOT (ATOM (CAR MATCH:P)))
(MEMQ (CAAR MATCH:P) '($R RESTRICT ⊗R)))
(CLAUSE-*-RESTRICTIONS MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((AND (NOT (ATOM (CAR MATCH:P)))
(MEMQ (CAAR MATCH:P) '($IR IRESTRICT ⊗IR)))
(CLAUSE-*-IRESTRICTIONS MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((EQ (CAR MATCH:P) '*)
;;; (* ...)
(CLAUSE-* MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((EQ (M-CHAR1 (CAR MATCH:P)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((AND (NOT (EQ (CAR MATCH:P) '=))
(EQ (M-CHAR1 (CAR MATCH:P)) '=))
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((AND (NOT (ATOM (CAR MATCH:D)))
(MEMQ (CAAR MATCH:D) '($R RESTRICT ⊗R))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (MATCH:PRED) (COND ((OR (RESTRICTP (CAR MATCH:P))
(M-SPECIAL-FORMP (CAR MATCH:P))
(FUNCALL MATCH:PRED (CAR MATCH:P)))
T))))
(CDDAR MATCH:D))))
(COND ((EQ (M-CHAR1 (CADAR MATCH:D)) '?)
(COND ((NULL MATCH:P)(*THROW 'MATCH:DECISION-POINT ()))
(T (CLAUSE-?-RESTRICTIONS MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))))
((AND (NOT (EQ (CADAR MATCH:P) '=))
(EQ (M-CHAR1 (CADAR MATCH:P)) '=))
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ MATCH:P (CONS (LIST (CAAR MATCH:P) VAR (CDDAR MATCH:P))
(CDR MATCH:P))))
(T (SETQ MATCH:P (CONS (LIST (CAAR MATCH:P) VAR (CDDAR MATCH:P))
(CDR MATCH:P))
MATCH:ALIST (CONS (CONS VAR (SYMEVAL VAR))
MATCH:ALIST)))))
(ASSQ VAR MATCH:ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR MATCH:P)))))
(M-UMATCH P D CP CD ALIST NOBIND))
(T (*THROW 'MATCH:DECISION-POINT () ))))
((AND (NOT (ATOM (CAR MATCH:D)))
(MEMQ (CAAR MATCH:D) '($R RESTRICT ⊗R)))
(CLAUSE-*-RESTRICTIONS MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((AND (NOT (ATOM (CAR MATCH:D)))
(MEMQ (CAAR MATCH:D) '($IR IRESTRICT ⊗IR)))
(CLAUSE-*-IRESTRICTIONS MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((EQ (CAR MATCH:D) '*)
;;; (* ...)
(CLAUSE-* MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((EQ (M-CHAR1 (CAR MATCH:D)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((AND (NOT (EQ (CAR MATCH:D) '=))
(EQ (M-CHAR1 (CAR MATCH:D)) '=))
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((OR (EQ (CAR MATCH:P) '?) (EQ (CAR MATCH:D) '?))
;;; easiest case
(SETQ MATCH:P (CDR MATCH:P) MATCH:D (CDR MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND))
((EQ (M-CHAR1 (CAR MATCH:P)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((EQ (M-CHAR1 (CAR MATCH:D)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((EQ (CAR MATCH:P) (CAR MATCH:D))
;;; easiest case
(SETQ MATCH:P (CDR MATCH:P) MATCH:D (CDR MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND))
((CHOOSEP (CAR MATCH:P))
(CHOOSE-CLAUSE MATCH:P MATCH:D MATCH:CP MATCH:CD MATCH:ALIST))
((CHOOSEP (CAR MATCH:D))
(CHOOSE-CLAUSE MATCH:D MATCH:P MATCH:CD MATCH:CP MATCH:ALIST))
((AND (NOT (ATOM (CAR MATCH:P)))
(OR (NULL (CAR MATCH:D))(NOT (ATOM (CAR MATCH:D)))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
MATCH:CP (CONS (CDR MATCH:P) MATCH:CP)
MATCH:CD (CONS (CDR MATCH:D) MATCH:CD)
MATCH:P (CAR MATCH:P) MATCH:D (CAR MATCH:D))
(M-UMATCH P D CP CD ALIST NOBIND)))
(*THROW 'MATCH:DECISION-POINT () ))))
;;*page